home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / expect.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  5.5 KB  |  172 lines
  1. ;;;;     Copyright (C) 1996, 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17.  
  18. ;;; Commentary:
  19.  
  20. ;; This module is documented in the Guile Reference Manual.
  21. ;; Briefly, these are exported:
  22. ;;  procedures: expect-select, expect-regexec
  23. ;;   variables: expect-port, expect-timeout, expect-timeout-proc,
  24. ;;              expect-eof-proc, expect-char-proc,
  25. ;;              expect-strings-compile-flags, expect-strings-exec-flags,
  26. ;;      macros: expect, expect-strings
  27.  
  28. ;;; Code:
  29.  
  30. (define-module (ice-9 expect)
  31.   :use-module (ice-9 regex)
  32.   :export-syntax (expect expect-strings)
  33.   :export (expect-port expect-timeout expect-timeout-proc
  34.        expect-eof-proc expect-char-proc expect-strings-compile-flags
  35.        expect-strings-exec-flags expect-select expect-regexec))
  36.  
  37. ;;; Expect: a macro for selecting actions based on what it reads from a port.
  38. ;;; The idea is from Don Libes' expect based on Tcl.
  39. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  40.  
  41.  
  42. (define expect-port #f)
  43. (define expect-timeout #f)
  44. (define expect-timeout-proc #f)
  45. (define expect-eof-proc #f)
  46. (define expect-char-proc #f)
  47.  
  48. ;;; expect: each test is a procedure which is applied to the accumulating
  49. ;;; string.
  50. (defmacro expect clauses
  51.   (let ((s (gensym))
  52.     (c (gensym))
  53.     (port (gensym))
  54.     (timeout (gensym)))
  55.     `(let ((,s "")
  56.        (,port (or expect-port (current-input-port)))
  57.        ;; when timeout occurs, in floating point seconds.
  58.        (,timeout (if expect-timeout
  59.              (let* ((secs-usecs (gettimeofday)))
  60.                (+ (car secs-usecs)
  61.                   expect-timeout
  62.                   (/ (cdr secs-usecs)
  63.                  1000000))) ; one million.
  64.              #f)))
  65.        (let next-char ()
  66.      (if (and expect-timeout
  67.           (not (expect-select ,port ,timeout)))
  68.          (if expect-timeout-proc
  69.          (expect-timeout-proc ,s)
  70.          #f)
  71.          (let ((,c (read-char ,port)))
  72.            (if expect-char-proc
  73.            (expect-char-proc ,c))
  74.            (if (not (eof-object? ,c))
  75.            (set! ,s (string-append ,s (string ,c))))
  76.            (cond
  77.         ;; this expands to clauses where the car invokes the
  78.         ;; match proc and the cdr is the return value from expect
  79.         ;; if the proc matched.
  80.         ,@(let next-expr ((tests (map car clauses))
  81.                   (exprs (map cdr clauses))
  82.                   (body '()))
  83.             (cond
  84.              ((null? tests)
  85.               (reverse body))
  86.              (else
  87.               (next-expr
  88.                (cdr tests)
  89.                (cdr exprs)
  90.                (cons
  91.             `((,(car tests) ,s (eof-object? ,c))
  92.               ,@(cond ((null? (car exprs))
  93.                    '())
  94.                   ((eq? (caar exprs) '=>)
  95.                    (if (not (= (length (car exprs))
  96.                            2))
  97.                        (scm-error 'misc-error
  98.                           "expect"
  99.                           "bad recipient: ~S"
  100.                           (list (car exprs))
  101.                           #f)
  102.                        `((apply ,(cadar exprs)
  103.                         (,(car tests) ,s ,port)))))
  104.                   (else
  105.                    (car exprs))))
  106.             body)))))
  107.         ;; if none of the clauses matched the current string.
  108.         (else (cond ((eof-object? ,c)
  109.                  (if expect-eof-proc
  110.                  (expect-eof-proc ,s)
  111.                  #f))
  112.                 (else
  113.                  (next-char)))))))))))
  114.  
  115.  
  116. (define expect-strings-compile-flags regexp/newline)
  117. (define expect-strings-exec-flags regexp/noteol)
  118.  
  119. ;;; the regexec front-end to expect:
  120. ;;; each test must evaluate to a regular expression.
  121. (defmacro expect-strings clauses
  122.   `(let ,@(let next-test ((tests (map car clauses))
  123.               (exprs (map cdr clauses))
  124.               (defs '())
  125.               (body '()))
  126.         (cond ((null? tests)
  127.            (list (reverse defs) `(expect ,@(reverse body))))
  128.           (else
  129.            (let ((rxname (gensym)))
  130.              (next-test (cdr tests)
  131.                 (cdr exprs)
  132.                 (cons `(,rxname (make-regexp
  133.                          ,(car tests)
  134.                          expect-strings-compile-flags))
  135.                       defs)
  136.                 (cons `((lambda (s eof?)
  137.                       (expect-regexec ,rxname s eof?))
  138.                     ,@(car exprs))
  139.                       body))))))))
  140.  
  141. ;;; simplified select: returns #t if input is waiting or #f if timed out or
  142. ;;; select was interrupted by a signal.
  143. ;;; timeout is an absolute time in floating point seconds.
  144. (define (expect-select port timeout)
  145.   (let* ((secs-usecs (gettimeofday))
  146.      (relative (- timeout
  147.               (car secs-usecs)
  148.               (/ (cdr secs-usecs)
  149.              1000000))))    ; one million.
  150.     (and (> relative 0)
  151.      (pair? (car (select (list port) '() '()
  152.                  relative))))))
  153.  
  154. ;;; match a string against a regexp, returning a list of strings (required
  155. ;;; by the => syntax) or #f.  called once each time a character is added
  156. ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
  157. (define (expect-regexec rx s eof?)
  158.   ;; if expect-strings-exec-flags contains regexp/noteol,
  159.   ;; remove it for the eof test.
  160.   (let* ((flags (if (and eof?
  161.              (logand expect-strings-exec-flags regexp/noteol))
  162.             (logxor expect-strings-exec-flags regexp/noteol)
  163.             expect-strings-exec-flags))
  164.      (match (regexp-exec rx s 0 flags)))
  165.     (if match
  166.     (do ((i (- (match:count match) 1) (- i 1))
  167.          (result '() (cons (match:substring match i) result)))
  168.         ((< i 0) result))
  169.     #f)))
  170.  
  171. ;;; expect.scm ends here
  172.